home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MEMORY.SWG / 0067_Huge Memory Allocation.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  2KB  |  108 lines
  1. {
  2. Here are the routines I wrote.  The PtrToLong routine is from TurboPower's
  3. OPINLINE unit; it just converts a pointer to a linear address, using
  4. 16*seg + ofs (in longint arithmetic, of course).  Other than that, I think
  5. everything should be obvious.
  6.  
  7. From: dmurdoch@mast.queensu.ca (Duncan Murdoch)
  8. }
  9.  
  10. {$ifndef dpmi}
  11.  
  12. type
  13.   PFreeRec = ^TFreeRec;
  14.   TFreeRec = record
  15.     next: PFreeRec;
  16.     size: Pointer;
  17.   end;
  18.  
  19. procedure GetMemHuge(var p:HugePtr;size:Longint);
  20. const
  21.   blocksize = $FFF0;
  22. var
  23.   prev,free : PFreeRec;
  24.   save,temp : pointer;
  25.   block : word;
  26. begin
  27.   { Handle the easy cases first }
  28.   if size > maxavail then
  29.     p := nil
  30.   else if size < 65521 then
  31.     getmem(p,size)
  32.   else
  33.   begin
  34. {$ifndef ver60}
  35.    {$ifndef ver70}
  36.     The code below is extremely version specific to the TP 6/7 heap manager!!
  37.    {$endif}
  38. {$endif}
  39.     { Find the block that has enough space }
  40.     prev := PFreeRec(@freeList);
  41.     free := prev^.next;
  42.     while (free <> heapptr) and (PtrToLong(free^.size) < size) do
  43.     begin
  44.       prev := free;
  45.       free := prev^.next;
  46.     end;
  47.  
  48.     { Now free points to a region with enough space; make it the first one
  49.       and multiple allocations will be contiguous. }
  50.  
  51.     save := freelist;
  52.     freelist := free;
  53.     { In TP 6, this works; check against other heap managers }
  54.     while size > 0 do
  55.     begin
  56.       block := minlong(blocksize,size);
  57.       dec(size,block);
  58.       getmem(temp,block);
  59.     end;
  60.  
  61.     { We've got what we want now; just sort things out and restore the
  62.       free list to normal }
  63.  
  64.     p := free;
  65.     if prev^.next <> freelist then
  66.     begin
  67.       prev^.next := freelist;
  68.       freelist := save;
  69.     end;
  70.   end;
  71. end;
  72.  
  73. procedure FreeMemHuge(var p:HugePtr;size : longint);
  74. const
  75.   blocksize = $FFF0;
  76. var
  77.   block : word;
  78. begin
  79.   while size > 0 do
  80.   begin
  81.     block := minlong(blocksize,size);
  82.     dec(size,block);
  83.     freemem(p,block);
  84.     p := Normalized(AddWordToPtr(p,block));
  85.   end;
  86. end;
  87. {$else}
  88.  
  89. Procedure GetMemHuge(var p : HugePtr; Size: LongInt);
  90. begin
  91.   if Size < 65521 then
  92.     GetMem(p,size)
  93.   else
  94.     p := GlobalAllocPtr(gmem_moveable,Size);
  95. end;
  96.  
  97. Procedure FreeMemHuge(var p : HugePtr; Size: Longint);
  98. var
  99.   h : THandle;
  100. begin
  101.   if Size < 65521 then
  102.     Freemem(p,size)
  103.   else
  104.     h := GlobalFreePtr(p);
  105. end;
  106.  
  107. {$endif}
  108.